PC Answers 1995 May

home *** CD-ROM | disk | FTP | other *** search

/ PC Answers 1995 May / PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso / vbits / code / mee / vbdao / visdata / tblstru.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1994-10-06 | 16.9 KB | 618 lines

VERSION 2.00 Begin Form fTblStru BackColor = &H00C0C0C0& Caption = "Table Structure" ClientHeight = 5550 ClientLeft = 2100 ClientTop = 1890 ClientWidth = 5040 Height = 5955 Icon = 0 Left = 2040 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 5550 ScaleWidth = 5040 Top = 1545 Width = 5160 Begin TextBox cTableName BackColor = &H00FFFFFF& Height = 288 Left = 1680 TabIndex = 0 Tag = "OLS" Top = 120 Width = 1932 End Begin PictureBox IndexBox BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 1692 Left = 0 ScaleHeight = 1695 ScaleWidth = 5055 TabIndex = 9 Top = 3720 Width = 5052 Begin CommandButton PrintButton Caption = "&Print Structure" Height = 372 Left = 720 TabIndex = 14 Top = 1320 Visible = 0 'False Width = 1452 End Begin CommandButton AddTableButton Caption = "&Build the Table" Enabled = 0 'False Height = 372 Left = 720 TabIndex = 8 Top = 1320 Visible = 0 'False Width = 1452 End Begin CommandButton CloseButton Cancel = -1 'True Caption = "&Close" Height = 372 Left = 2880 TabIndex = 3 Top = 1320 Width = 1452 End Begin CommandButton AddIndexButton Caption = "Add &Index" Height = 252 Left = 1200 TabIndex = 5 Top = 120 Width = 1332 End Begin CommandButton DelIndexButton Caption = "&Delete Index" Height = 252 Left = 2640 TabIndex = 6 Top = 120 Width = 1332 End Begin Grid cIndexes Cols = 4 FixedCols = 0 Height = 750 Left = 120 TabIndex = 2 Top = 420 Width = 4815 End Begin Line Line1 BorderWidth = 5 X1 = 0 X2 = 4800 Y1 = 0 Y2 = 0 End Begin Label IndexesLabel BackColor = &H00C0C0C0& Caption = "Indexes:" Height = 252 Left = 240 TabIndex = 10 Top = 120 Width = 1092 End End Begin PictureBox FieldBox BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 2892 Left = 0 ScaleHeight = 2895 ScaleWidth = 5055 TabIndex = 11 Top = 600 Width = 5052 Begin CommandButton RemoveFieldButton Caption = "&Remove Field" Height = 252 Left = 2625 TabIndex = 7 Top = 0 Width = 1332 End Begin CommandButton AddFieldButton Caption = "&Add Field" Height = 252 Left = 1200 TabIndex = 4 Top = 0 Width = 1332 End Begin Grid cFields BackColor = &H00FFFFFF& Cols = 3 FixedCols = 0 Height = 2532 Left = 120 TabIndex = 1 Top = 288 Width = 4800 End Begin Label FieldsLabel BackColor = &H00C0C0C0& Caption = "Fields:" Height = 192 Left = 240 TabIndex = 12 Top = 0 Width = 732 End End Begin Label TableNameLabel BackColor = &H00C0C0C0& Caption = "Table Name:" Height = 252 Left = 360 TabIndex = 13 Top = 120 Width = 1212 End Option Explicit Sub AddFieldButton_Click () MsgBar "Enter New Field Parameters, Press 'Close' when finished", False fAddField.Show MODAL MsgBar NULL_STR, False End Sub Sub AddIndexButton_Click () MsgBar "Enter New Index Parameters, Press 'Close' when finished", False fIndexAdd.Show MODAL MsgBar NULL_STR, False End Sub Sub AddTableButton_Click () Dim tbl As New TableDef Dim fld As Field Dim ind As Index Dim i As Integer Dim x As String On Error GoTo ATErr SetHourglass Me MsgBar "Building New Table", True tbl.Name = cTableName 'search to see if table exists For i = 0 To gCurrentDB.TableDefs.Count - 1 If UCase(gCurrentDB.TableDefs(i).Name) = UCase(tbl.Name) Then If MsgBox(tbl.Name & " already exists, delete it?", 4) = YES Then gCurrentDB.TableDefs.Delete gCurrentDB.TableDefs(tbl.Name) Else ResetMouse Me Exit Sub End If Exit For End If Next 'add the first field cFields.Row = 1 cFields.Col = 0 If Len(cFields) = 0 Then Beep MsgBox "No Fields Defined!", 48 Exit Sub End If Set fld = New Field fld.Name = cFields cFields.Col = 1 fld.Type = GetFieldType((cFields)) If cFields = "Counter" Then fld.Attributes = &H10 'counter type End If cFields.Col = 2 fld.Size = Val(cFields) tbl.Fields.Append fld gCurrentDB.TableDefs.Append tbl 'add the rest of the fields For i = 2 To cFields.Rows - 1 Set fld = New Field cFields.Row = i cFields.Col = 0 fld.Name = cFields cFields.Col = 1 fld.Type = GetFieldType((cFields)) If cFields = "Counter" Then fld.Attributes = &H10 'counter type End If cFields.Col = 2 fld.Size = Val(cFields) gCurrentDB.TableDefs(tbl.Name).Fields.Append fld Next 'add the indexes For i = 1 To cIndexes.Rows - 1 Set ind = New Index cIndexes.Row = i cIndexes.Col = 0 If Len(cIndexes) = 0 Then Exit For ind.Name = cIndexes cIndexes.Col = 1 ind.Fields = cIndexes cIndexes.Col = 2 If cIndexes = "True" Then ind.Unique = True Else ind.Unique = False End If cIndexes.Col = 3 If gstDataType = SQLDB Then cIndexes = "N/A" Else If cIndexes = "True" Then ind.Primary = True Else ind.Primary = False End If End If gCurrentDB.TableDefs(tbl.Name).Indexes.Append ind Next RefreshTables fTables.cTableList, True GoTo ATEnd ATErr: ResetMouse Me ShowError Exit Sub ATEnd: ResetMouse Me MsgBar NULL_STR, False Unload Me End Sub Sub cFields_DblClick () Dim f As New fDataBox Dim erm As String 'only allowed on existing tables If gfAddTableFlag = True Then Exit Sub End If On Error GoTo FldPropErr cFields.Row = cFields.SelStartRow cFields.Col = 0 Set gCurrentField = gCurrentDB.TableDefs(fTables.cTableList).Fields(cFields) f.caption = "Field Properties" f.Tag = "FLD" erm = "Name" f.cData.AddItem "Name = " & gCurrentField.Name erm = "Type" f.cData.AddItem "Type = " & gCurrentField.Type erm = "Size" f.cData.AddItem "Size = " & gCurrentField.Size erm = "SourceField" f.cData.AddItem "SourceField = " & gCurrentField.SourceField erm = "SourceTable" f.cData.AddItem "SourceTable = " & gCurrentField.SourceTable erm = "CollatingOrder" f.cData.AddItem "CollatingOrder = " & gCurrentField.CollatingOrder erm = "Attributes" f.cData.AddItem "Attributes = &H" & Hex(gCurrentField.Attributes) erm = "OrdinalPosition" f.cData.AddItem "OrdinalPosition = " & gCurrentField.OrdinalPosition f.Show MODAL GoTo FldPropEnd FldPropErr: f.cData.AddItem erm & ":" & Error$ Resume Next FldPropEnd: End Sub Sub cIndexes_DblClick () Dim f As New fDataBox Dim erm As String 'only allowed on existing tables If gfAddTableFlag = True Then Exit Sub End If On Error GoTo IndPropErr cIndexes.Row = cIndexes.SelStartRow cIndexes.Col = 0 Set gCurrentIndex = gCurrentDB.TableDefs(fTables.cTableList).Indexes(cIndexes) f.caption = "Field Properties" f.Tag = "IND" erm = "Name" f.cData.AddItem "Name = " & gCurrentIndex.Name erm = "Fields" f.cData.AddItem "Fields = " & gCurrentIndex.Fields erm = "Unique" f.cData.AddItem "Unique Flag = " & stTrueFalse((gCurrentIndex.Unique)) erm = "Primary" f.cData.AddItem "PrimaryFlag = " & stTrueFalse((gCurrentIndex.Primary)) f.Show MODAL GoTo IndPropEnd IndPropErr: f.cData.AddItem erm & ":" & Error$ Resume Next IndPropEnd: End Sub Sub CloseButton_Click () Unload Me MsgBar NULL_STR, False End Sub Sub cTableName_Change () If Len(cTableName) = 0 Then AddTableButton.Enabled = False Else AddTableButton.Enabled = True End If End Sub Sub cTableName_KeyPress (KeyAscii As Integer) If cTableName.TabStop = False Then KeyAscii = 0 'throw away the key End If End Sub Sub DelIndexButton_Click () On Error GoTo DELErr cIndexes.Row = cIndexes.SelStartRow cIndexes.Col = 0 If Len(cIndexes) = 0 Then Exit Sub If MsgBox("Delete """ & cIndexes & """ index?", MSGBOX_TYPE) = YES Then If gfAddTableFlag = False Then gCurrentDB.TableDefs(fTables.cTableList).Indexes.Delete gCurrentDB.TableDefs(fTables.cTableList).Indexes(cIndexes) End If 'refresh the list of indexes If cIndexes.Rows = 2 Then cIndexes.Col = 0 cIndexes = NULL_STR cIndexes.Col = 1 cIndexes = NULL_STR cIndexes.Col = 2 cIndexes = NULL_STR Else cIndexes.RemoveItem cIndexes.Row End If End If Exit Sub DELErr: ShowError Exit Sub End Sub Sub Form_Load () Dim tbl As TableDef Dim i As Integer Dim s As String On Error GoTo LoadErr Width = 5160 Height = 5955 SetHourglass Me fTables.MousePointer = HOURGLASS MsgBar "Opening Design Form", True fTblStru.cTableName.TabStop = gfAddTableFlag 'setup field grid titles cFields.ColWidth(0) = 2500 cFields.ColWidth(1) = 1500 cFields.ColWidth(2) = 500 cFields.Row = 0 cFields.Col = 0 cFields = "Name" cFields.Col = 1 cFields = "Type" cFields.Col = 2 cFields = "Size" 'setup index grid titles cIndexes.ColWidth(0) = 850 cIndexes.ColWidth(1) = 2250 cIndexes.ColWidth(2) = 650 cIndexes.ColWidth(3) = 700 cIndexes.Row = 0 cIndexes.Col = 0 cIndexes = "Name" cIndexes.Col = 1 cIndexes = "Indexed Fields" cIndexes.Col = 2 cIndexes = "Unique" cIndexes.Col = 3 cIndexes = "Primary" If gfAddTableFlag = True Then caption = "Add Table" AddTableButton.Visible = True cFields.Rows = 2 cIndexes.Rows = 2 Else caption = "View/Modify Structure" PrintButton.Visible = True RemoveFieldButton.Visible = False fTblStru.cTableName = fTables.cTableList Set tbl = gCurrentDB.TableDefs(fTables.cTableList) cFields.Rows = tbl.Fields.Count + 1 For i = 1 To cFields.Rows - 1 cFields.Row = i cFields.Col = 0 cFields = tbl.Fields(i - 1).Name cFields.Col = 1 Select Case tbl.Fields(i - 1).Type Case FT_TRUEFALSE s = "True/False" Case FT_BYTE s = "Byte" Case FT_INTEGER s = "Integer" Case FT_LONG If tbl.Fields(i - 1).Attributes And &H10 = &H10 Then s = "Counter" Else s = "Long" End If Case FT_CURRENCY s = "Currency" Case FT_SINGLE s = "Single" Case FT_DOUBLE s = "Double" Case FT_DATETIME s = "Date/Time" Case 9 s = "Reserved/9" Case FT_STRING s = "String" Case FT_BINARY s = "Binary" Case FT_MEMO s = "Memo" Case Else s = CStr(tbl.Fields(i - 1).Type) End Select cFields = s cFields.Col = 2 cFields = CStr(tbl.Fields(i - 1).Size) Next If tbl.Indexes.Count = 0 Then cIndexes.Rows = 2 Else cIndexes.Rows = tbl.Indexes.Count + 1 For i = 1 To cIndexes.Rows - 1 cIndexes.Row = i cIndexes.Col = 0 cIndexes = tbl.Indexes(i - 1).Name cIndexes.Col = 1 cIndexes = tbl.Indexes(i - 1).Fields cIndexes.Col = 2 If tbl.Indexes(i - 1).Unique = False Then s = "False" Else s = "True" End If cIndexes = s cIndexes.Col = 3 If gstDataType = SQLDB Then s = "N/A" Else If tbl.Indexes(i - 1).Primary = False Then s = "False" Else s = "True" End If End If cIndexes = s Next End If End If 'lock the titles row and set the selected cell cFields.Row = 1 cFields.SelStartCol = 0 cFields.SelEndCol = 0 cFields.FixedRows = 1 cIndexes.Row = 1 cIndexes.SelStartCol = 0 cIndexes.SelEndCol = 0 cIndexes.FixedRows = 1 ResizeFieldGrid GoTo LoadEnd LoadErr: ResetMouse Me fTables.MousePointer = DEFAULT_MOUSE ShowError Unload Me MsgBar NULL_STR, False Exit Sub Resume LoadEnd LoadEnd: ResetMouse Me fTables.MousePointer = DEFAULT_MOUSE MsgBar NULL_STR, False End Sub Sub Form_Paint () Outlines Me FieldBox.Refresh PicOutlines FieldBox, cFields IndexBox.Refresh PicOutlines IndexBox, cIndexes End Sub Sub Form_Resize () On Error Resume Next If WindowState <> 1 Then If Width < 5190 Then Width = 5190 End If FieldBox.Width = Width ' - 350 cFields.Width = FieldBox.Width - 350 IndexBox.Width = Width ' - 350 cIndexes.Width = IndexBox.Width - 350 Line1.X2 = IndexBox.Width Form_Paint End If End Sub Sub PrintButton_Click () 'this routine simply prints the currently 'selected table's definition Dim i As Integer Dim s As String MsgBar "Printing Table Structure", True Printer.Print Printer.Print Printer.Print Printer.Print "DataBase: " & gstDBName Printer.Print Printer.Print Printer.Print "Table Definition for " & cTableName Printer.Print Printer.Print Printer.Print "Fields: (Name - Type - Size)" Printer.Print String(60, "-") For i = 1 To cFields.Rows - 1 cFields.Row = i cFields.Col = 0 s = cFields & " - " cFields.Col = 1 s = s + cFields & " - " cFields.Col = 2 s = s + cFields Printer.Print s Next Printer.Print Printer.Print Printer.Print "Index List (Name - Fields - Unique)" Printer.Print String(60, "-") For i = 1 To cIndexes.Rows - 1 cIndexes.Row = i cIndexes.Col = 0 s = cIndexes & " - " cIndexes.Col = 1 s = s + cIndexes & " - " cIndexes.Col = 2 s = s + cIndexes Printer.Print s Next Printer.NewPage Printer.EndDoc MsgBar NULL_STR, False End Sub Sub RemoveFieldButton_Click () On Error GoTo RFErr cFields.Row = cFields.SelStartRow cFields.Col = 0 If Len(cFields) = 0 Then Exit Sub If MsgBox("Remove """ & cFields & """ field?", MSGBOX_TYPE) = YES Then 'refresh the list of indexes If cFields.Rows = 2 Then cFields.Col = 0 cFields = NULL_STR cFields.Col = 1 cFields = NULL_STR cFields.Col = 2 cFields = NULL_STR Else cFields.RemoveItem cFields.Row ResizeFieldGrid End If End If GoTo RFEnd RFErr: ShowError Resume RFEnd RFEnd: End Sub Sub ResizeFieldGrid () If cFields.Rows < 12 Then cFields.Height = cFields.Rows * 245 FieldBox.Height = cFields.Height + 360 IndexBox.Top = FieldBox.Top + FieldBox.Height + 250 Height = IndexBox.Top + IndexBox.Height + 500 End If End Sub